Machine Learning and Survival Analysis

Predicting customer churn using complex statistical modeling

Examining the Data

NoteKaggle Synthetic Data

The dataset utilized in this analysis comes from Kaggle: https://www.kaggle.com/datasets/sakshigoyal7/credit-card-customers

This comprehensive data science project aimed at identifying, analyzing, and predicting customer attrition within a consumer credit card division. Leveraging a dataset of over 10,000 historic records, the project moves beyond basic reporting to provide actionable risk intelligence.

The dataset consists of anonymized customer data for current and former credit card customers, and includes both demographic data (gender, age, marital status, income, education) and account data (credit limit, revolving balance, transaction information, communication with bank information, etc.). Customer churn (former bank customers) accounts for about 16% of the dataset.

The goals of the project:

• Identify Drivers: Use Logistic Regression to isolate the “Risk Multipliers” that lead to account closure.
• Predict Risk: Deploy a Random Forest machine learning model to score existing customers on their probability of churn.
• Analyze Lifecycle: Utilize Survival Analysis to map the “Customer Life Expectancy” and identify critical tenure milestones.
• Tactical Action: Create a prioritized outreach list of at-risk active customers.

attritionDataSubset <- attritionData %>%
  select(customer.age,
         months.on.book,
         total.relationship.count,
         months.inactive.12.months,
         contacts.count.12.month,
         credit.limit,
         total.revolving.balance,
         avg.open.to.buy,
         total.amount.changed.previous.quarter,
         total.transaction.amount,
         total.transaction.count,
         avg.utilization.rate
         )

summary_data <- attritionDataSubset %>%
  pivot_longer(cols = everything(), names_to = "metric") %>%
  group_by(metric) %>%
  summarize(
    max = max(value),
    min = min(value),
    mean = mean(value),
    std_dev = sd(value),
    first_qrt = quantile(value, probs = .25),
    third_qrt = quantile(value, probs = .75)) %>%
  mutate(metric = case_when(
      metric == "customer.age" ~ "Customer Age",
      metric == "months.on.book" ~ "Months on Book",
      metric == "total.relationship.count" ~ "Total Relationship Count",
      metric == "months.inactive.12.months" ~ "Months Inactive Past Year",
      metric == "contacts.count.12.month" ~ "Bank Communications Past Year",
      metric == "credit.limit" ~ "Credit Limit",
      metric == "total.revolving.balance" ~ "Total Revolving Balance",
      metric == "avg.open.to.buy" ~ "Average Open to Buy",
      metric == "total.amount.changed.previous.quarter" ~ "Total Amount Changed Previous Quarter",
      metric == "total.transaction.amount" ~ "Total Transaction Amount",
      metric == "total.transaction.count" ~ "Total Transaction Count",
      metric == "avg.utilization.rate" ~ "Average Utilization Rate")) %>%
  relocate(metric, min, first_qrt, mean, third_qrt, max, std_dev) %>%
  select(Metric = metric, 
         Minimum = min,
         "1st Quartile" = first_qrt,
         Mean = mean,
         "3rd Quartile" = third_qrt,
         Maximum = max,
         "Std Dev" = std_dev)

kbl(summary_data,caption = "Summary of Quantitative Date from Dataset", digits = 1, align = ("lcccr")) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed", full_width = F), fixed_thead = T) %>%
scroll_box(width = "100%", height = "480px")

Summary of Quantitative Date from Dataset

Metric	Minimum	1st Quartile	Mean	3rd Quartile	Maximum	Std Dev
Average Open to Buy	3.0	1324.5	7469.1	9859.0	34516.0	9090.7
Average Utilization Rate	0.0	0.0	0.3	0.5	1.0	0.3
Bank Communications Past Year	0.0	2.0	2.5	3.0	6.0	1.1
Credit Limit	1438.3	2555.0	8632.0	11067.5	34516.0	9088.8
Customer Age	26.0	41.0	46.3	52.0	73.0	8.0
Months Inactive Past Year	0.0	2.0	2.3	3.0	6.0	1.0
Months on Book	13.0	31.0	35.9	40.0	56.0	8.0
Total Amount Changed Previous Quarter	0.0	0.6	0.8	0.9	3.4	0.2
Total Relationship Count	1.0	3.0	3.8	5.0	6.0	1.6
Total Revolving Balance	0.0	359.0	1162.8	1784.0	2517.0	815.0
Total Transaction Amount	510.0	2155.5	4404.1	4741.0	18484.0	3397.1
Total Transaction Count	10.0	45.0	64.9	81.0	139.0	23.5

Visualizing Risk: A Comparative View

NoteUnderstanding the Behavioral Gap

To determine why customers leave, behavioral signatures—patterns in how individuals use their cards before closing an account are examined. In this analysis, Exploratory Data Analysis (EDA) is utilized to compare the habits of over 10,000 customers. By charting transaction counts against transaction amounts, current at-risk customers can be better identified.

Statistical analysis shows that churned customers aren’t necessarily those with the lowest credit limits; rather, they are the ones who have stopped integrating the card into their daily routine. Identifying this drop in transaction velocity might allow the bank to intervene weeks or months before a customer formally requests to cancel, transforming the strategy from reactive damage control to proactive relationship management.

Interactive comparison of transaction counts and total spending.

#| label: visual-analysis
#| fig-cap: "Interactive comparison of transaction counts and total spending."

# Corrected interactive scatter plot using exact column names 
p <- ggplot(attritionData, aes(x = total.transaction.count, y = total.transaction.amount, color = churn)) +
  geom_point(alpha = 0.3) +
  scale_color_manual(values = c("Existing Customer" = "#3e3f3a", "Attrited Customer" = "#df691a")) +
  labs(title = "Transaction Velocity: Usage vs. Attrition Status",
       x = "Total Transaction Count (Annual)",
       y = "Total Transaction Amount ($)",
       color = "Status") +
  theme_minimal()

ggplotly(p)

NoteSegmenting Attrition Across Key Factors

While the Transaction Velocity plot provides a high-level view of account usage, attrition risk is sometimes distributed unevenly across different demographic segments. In this section, a series of comparative plots is created that may allow the reader to observe how attrition rates fluctuate across variables such as age, gender, marital status, income and education. In this case, however, there seem to be no real outliers that could provide realistic insight as to why customer stay or leave.

# Visualization by Gender
plotGender <- ggplot(attritionData, aes(x = gender, fill = churn)) +
  geom_bar(position = "fill", alpha = 0.8) +
  scale_fill_manual(values = c("Existing Customer" = "#e5e4e2", "Attrited Customer" = "#df691a")) +
  scale_y_continuous(labels = scales::percent) + 
  labs(subtitle  = "Gender",
       x = "",
       y = "",
       fill = "Status") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  theme(legend.position="none")

# Visualization by Age
plotAge <- ggplot(attritionData, aes(x = age.bracket, fill = churn)) +
  geom_bar(position = "fill", alpha = 0.8) +
  scale_fill_manual(values = c("Existing Customer" = "#e5e4e2", "Attrited Customer" = "#df691a")) +
  scale_y_continuous(labels = scales::percent) + 
  labs(subtitle  = "Age",
       x = "",
       y = "",
       fill = "Status") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  theme(legend.position="bottom")

# Visualization by Marital Status
plotMaritalStatus <- ggplot(attritionData, aes(x = marital.status, fill = churn)) +
  geom_bar(position = "fill", alpha = 0.8) +
  scale_fill_manual(values = c("Existing Customer" = "#e5e4e2", "Attrited Customer" = "#df691a")) +
  scale_y_continuous(labels = scales::percent) + 
  labs(subtitle  = "Marital Status",
       x = "",
       y = "",
       fill = "Status") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  theme(legend.position="none") +
  theme(legend.position = "none")

# Visualization by Income
plotIncome <- ggplot(attritionData, aes(x = income.bracket, fill = churn)) +
  geom_bar(position = "fill", alpha = 0.8) +
  scale_fill_manual(values = c("Existing Customer" = "#e5e4e2", "Attrited Customer" = "#df691a")) +
  scale_y_continuous(labels = scales::percent) + 
  labs(subtitle = "Income",
       x = "",
       y = "",
       fill = "Status") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  theme(legend.position="none")

# Visualization by Edcuation Level
plotEducation <- ggplot(attritionData, aes(x = education.level, fill = churn)) +
  geom_bar(position = "fill", alpha = 0.8) +
  scale_fill_manual(values = c("Existing Customer" = "#e5e4e2", "Attrited Customer" = "#df691a")) +
  scale_y_continuous(labels = scales::percent) + 
  labs(subtitle = "Education",
       x = "",
       y = "",
       fill = "Status") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  theme(legend.position="none")


(plotGender + plotAge + plotMaritalStatus) / (plotIncome + plotEducation) + plot_annotation(title = 'Customer Attrition Segmentation Across Multiple Factors')

# plotIncome + plotEducation + plot_annotation(title = 'Customer Attrition Segmentation Across Income & Education')

Statistical Drivers

NoteIdentifying the “Why” with Risk Multipliers

To move beyond simple charts, Logistic regression is utilized to calculate the Risk Multiplier (mathematically, the “exponentiated coefficient”). This multiplier is calculated by taking the raw statistical weights and transforming them into a scale that represents the “Odds of Churn.”

How to Interpret the Numbers:

Multiplier > 1 (Risk Driver): This indicates that as this factor increases, the risk of attrition increases. A multiplier of 1.20 means that for every one-unit increase in that factor, the likelihood of a customer leaving grows by 20%.

Multiplier = 1 (Neutral): This means the factor has no impact on the risk of attrition. It is a neutral variable that does not help us predict whether a customer will stay or leave.

Multiplier < 1 (Protective Factor): This indicates that as this factor increases, the risk of attrition decreases. A multiplier of 0.80 means that for every one-unit increase, the risk of churn is reduced by 20%.

In this updated view, all variables in the model are included to provide a complete picture of every factor recorded by the bank, from age to revolving balance.

#| label: drivers-table

# Fit logistic regression including 'all' significant drivers from the dataset
logit_model <- logistic_reg() %>%
  set_engine("glm") %>%
  fit(churn ~ . - client.id - attrition.flag, data = attritionData)

# Formatting the comprehensive drivers table
all_drivers_table <- tidy(logit_model, exponentiate = TRUE) %>%
  filter(term != "(Intercept)") %>%
  mutate(
    term = str_to_title(str_replace_all(term, "\\.", " ")),
    Impact = case_when(
      estimate > 1.05 ~ "Higher Risk",
      estimate < 0.95 ~ "Protective Factor",
      TRUE ~ "Neutral"
    )
  ) %>%
  select(Factor = term, `Risk Multiplier` = estimate, Impact) %>%
  arrange(desc(`Risk Multiplier`)) 

tblData <- all_drivers_table %>%
  filter(Factor != "Avg Open To Buy") %>%
  mutate(Factor = case_when(
      Factor == "Age Bracket50-59" ~ "Age Bracket: 50-59",
      Factor == "Age Bracket40-49" ~ "Age Bracket: 40-49",
      Factor == "Age Bracket60+" ~ "Age Bracket: 60+",
      Factor == "Age Bracket30-39" ~ "Age Bracket: 30-39",
      Factor == "Card Categorygold" ~ "Card Category: Gold",
      Factor == "Card Categoryplatinum" ~ "Card Category: Platinum",
      Factor == "Income Bracket>$120k" ~ "Income: > $120k",
      Factor == "Contacts Count 12 Month" ~ "Previous Year Contacts",
      Factor == "Months Inactive 12 Months" ~ "Months Inactive Previous 12 Months",
      Factor == "Income Bracket$80k-$120k" ~ "Income: $80k to $120k",
      Factor == "Card Categorysilver" ~ "Card Category: Silver",
      Factor == "Education Leveldoctorate" ~ "Education Level: Doctorate",
      Factor == "Education Levelpost-Graduate" ~ "Education Level: Post Graduate",
      Factor == "Dependent Count" ~ "Number of Dependents",
      Factor == "Income Bracket$60k-$80k" ~ "Income: $60k to $80k",
      Factor == "Education Levelunknown" ~ "Education Level: Unknown",
      Factor == "Total Transaction Amount" ~ "Total Transaction Amount",
      Factor == "Credit Limit" ~ "Credit Limit",
      Factor == "Total Revolving Balance" ~ "Total Revolving Balance",
      Factor == "Months On Book" ~ "Months On Book",
      Factor == "Customer Age" ~ "Customer Age",
      Factor == "Education Levelhigh School" ~ "Education Level: High School",
      Factor == "Income Bracketunknown" ~ "Income: Unknown",
      Factor == "Marital Statusunknown" ~ "Marital Status: Unknown",
      Factor == "Education Levelcollege" ~ "Education Level: College",
      Factor == "Education Levelgraduate" ~ "Education Level: Graduate",
      Factor == "Marital Statusdivorced" ~ "Marital Status: Divorced",
      Factor == "Total Transaction Count" ~ "Total Transaction Count",
      Factor == "Avg Utilization Rate" ~ "Average Utilization Rate",
      Factor == "Income Bracket$40k-$60k" ~ "Income: $40k to $60k",
      Factor == "Total Amount Changed Previous Quarter" ~ "Total Amount Changed Previous Quarter",
      Factor == "Total Relationship Count" ~ "Total Relationship Count",
      Factor == "Marital Statusmarried" ~ "Marital Status: Married",
      Factor == "Gendermale" ~ "Gender: Male",
      Factor == "Total Count Change Previous Quarter" ~ "Total Count Change Previous Quarter")
      )

  kbl(tblData, caption = "Comprehensive Analysis of All Account Drivers", digits = 2) %>%
  kable_styling(bootstrap_options = c("striped", "hover", "condensed"), full_width = F) %>%
  column_spec(3, color = "white", 
              background = case_when(
                all_drivers_table$Impact == "Higher Risk" ~ "#df691a",
                all_drivers_table$Impact == "Protective Factor" ~ "#5cb85c",
                TRUE ~ "#999999")
              ) %>%
    scroll_box(width = "100%", height = "500px")

Comprehensive Analysis of All Account Drivers

Factor	Risk Multiplier	Impact
Age Bracket: 50-59	14.67	Higher Risk
Age Bracket: 40-49	13.90	Higher Risk
Age Bracket: 60+	11.35	Higher Risk
Age Bracket: 30-39	7.06	Higher Risk
Card Category: Gold	2.91	Higher Risk
Card Category: Platinum	2.61	Higher Risk
Income: > $120k	1.92	Higher Risk
Previous Year Contacts	1.69	Higher Risk
Months Inactive Previous 12 Months	1.66	Higher Risk
Card Category: Silver	1.56	Higher Risk
Income: $80k to $120k	1.41	Higher Risk
Education Level: Post Graduate	1.31	Higher Risk
Education Level: Doctorate	1.29	Higher Risk
Education Level: Unknown	1.07	Higher Risk
Number of Dependents	1.03	Neutral
Total Transaction Amount	1.00	Neutral
Income: $60k to $80k	1.00	Neutral
Credit Limit	1.00	Neutral
Total Revolving Balance	1.00	Neutral
Income: Unknown	1.00	Neutral
Months On Book	1.00	Neutral
Average Utilization Rate	0.96	Neutral
Education Level: High School	0.96	Neutral
Customer Age	0.96	Neutral
Education Level: College	0.94	Protective Factor
Education Level: Graduate	0.93	Protective Factor
Total Transaction Count	0.89	Protective Factor
Marital Status: Unknown	0.87	Protective Factor
Income: $40k to $60k	0.84	Protective Factor
Marital Status: Divorced	0.81	Protective Factor
Total Amount Changed Previous Quarter	0.67	Protective Factor
Total Relationship Count	0.64	Protective Factor
Marital Status: Married	0.52	Protective Factor
Gender: Male	0.47	Protective Factor
Total Count Change Previous Quarter	0.06	Protective Factor

Predictive Intelligence

NoteDecoding the Predictive Ranking Scale

The horizontal axis, labeled “Importance Score”, represents the predictive contribution of each factor. In this analysis, a calculation called Gini Impurity is used to determine these scores. Think of impurity as the amount of uncertainty or “clutter” in the data. Every time the model uses a variable like Transaction Count to successfully sort customers into “Stay” or “Leave” buckets, it reduces that clutter.

The scale (ranging from 0 to 250) is a calculated aggregate score, not a direct count of customers. It represents the total amount of clarity gained across all the thousands of decision trees in the model. While a larger database allows for more complex splits—which can result in higher total numbers—the absolute value is less important than the relative distance between the bars. For example, if one factor has a score of 180 and another has 60, the first is three times as powerful at helping predict the future status of an account. The ranking helps ensure that the model is prioritized around the same high-impact behaviors—like usage velocity and revolving balances—that industry experience suggests are the true drivers of risk.

What is a bit perplexing, is that overall age component does not seem to have significant influence as a key indicator of future customer attrition based on the random forest model results below, but certain age factors (ages > 50) rank extremely high on the risk multiplier plot above. More investigative work needs to be performed to better explain the apparent discrepancy.

# Build Random Forest model - explicitly excluding target variables to prevent data leakage
rf_model <- rand_forest() %>%
  set_engine("ranger", importance = "impurity") %>%
  set_mode("classification") %>%
  fit(churn ~ . - client.id - attrition.flag, data = attritionData)

# 1. Importance Plot: Visualizing the predictive 'heavy lifters' using native ggplot
importance_data <- vi(rf_model) %>%
  mutate(Variable = str_to_title(str_replace_all(Variable, "\\.", " ")))

ggplotData <- importance_data %>%
  filter(Variable != "Attrition Flag") %>%    ## Exclude "Attrition Flag" data from plot
  filter(Variable != "Client Id")             ## Exclude "Client Id" data from plot

importancePlot <- ggplot(ggplotData, aes(x = Importance, y = reorder(Variable, Importance))) +
  geom_col(fill = "#df691a", alpha = 0.8) +
  labs(title = "Predictive Ranking: Key Indicators of Customer Attrition",
       subtitle = "Calculated relative contribution to model accuracy",
       x = "Importance Score (Weighted Information Gain)",
       y = "Customer Attribute") +
  xlim(0, 250) +
  theme_minimal()

importancePlot

High-Risk Attrition List Customers

NoteIdentifying customers at risk for attrition

After examining the data, all current customers were ranked from high to low in terms of the calculated probability for them to depart. As one can see, even the highest ranking at-risk customer only has a calculated probability to leave of 10%. The next step would be to drill-down on these at-risk customers to refine the actual probability of departure. More data is needed to improve confidence in the model. As is the case with most machine learning and logistic regression analysis, the quality of the outcome is only as good as the quality of the data.

# Generate tactical high-risk list for EXISTING CUSTOMERS ONLY
high_risk_targets <- predict(rf_model, attritionData, type = "prob") %>%
  rename_with(~"churn_prob", starts_with(".pred_Attrited")) %>% 
  bind_cols(attritionData %>% select(client.id, 
                                     gender, 
                                     age.bracket, 
                                     income.bracket, 
                                     card.category, 
                                     total.revolving.balance,
                                     total.transaction.amount,
                                     contacts.count.12.month, 
                                     attrition.flag)) %>%
  filter(attrition.flag == "Existing Customer") %>%
  arrange(desc(churn_prob)) 

tblData <- high_risk_targets %>%
  select(ClientID = client.id,
         Gender = gender,
         "Age Bracket" = age.bracket, 
         Income = income.bracket, 
         'Outstanding Balance' = total.revolving.balance, 
         `Churn Probability` = churn_prob, 
         `Card Tier` = card.category, 
         "Recent Transaction Amount" = total.transaction.amount,
         `Recent Contacts` = contacts.count.12.month) %>%
        relocate(ClientID, 
                 Gender, 
                 "Age Bracket", 
                 Income, 
                 "Card Tier", 
                 "Outstanding Balance", 
                 "Recent Transaction Amount",
                 "Recent Contacts", 
                 "Churn Probability") %>%
        slice(1:50)

tblData$"Churn Probability" <- formattable::percent(tblData$"Churn Probability")
tblData$"Outstanding Balance" <- formattable::currency(tblData$"Outstanding Balance", "$", format = "d")
tblData$"Recent Transaction Amount" <- formattable::currency(tblData$"Recent Transaction Amount", "$", format = "d")

kbl(tblData,caption = "Tactical Outreach List: Top 50 Highest At-Risk ACTIVE Accounts", digits = 3, align = ("lcclcrccr")) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed", full_width = F), fixed_thead = T) %>%
scroll_box(width = "100%", height = "500px")

Tactical Outreach List: Top 50 Highest At-Risk ACTIVE Accounts

ClientID	Gender	Age Bracket	Income	Card Tier	Outstanding Balance	Recent Transaction Amount	Recent Contacts	Churn Probability
785432733	Female	40-49	<$40k	Gold	$ 0	$966	3	9.86%
709465758	Female	60+	<$40k	Blue	$ 0	$902	3	9.14%
710241858	Female	30-39	<$40k	Blue	$ 0	$2,040	4	8.48%
710662158	Male	40-49	>$120k	Blue	$2,517	$2,051	3	7.99%
721425558	Male	50-59	>$120k	Blue	$ 0	$1,536	2	7.87%
709106358	Male	40-49	$60k-$80k	Blue	$ 0	$816	0	7.76%
823629333	Male	40-49	$40k-$60k	Blue	$ 0	$4,220	1	7.75%
717975333	Male	50-59	$80k-$120k	Blue	$1,330	$837	2	7.45%
712215258	Female	50-59	$40k-$60k	Silver	$ 0	$1,298	3	7.39%
710044308	Female	40-49	$40k-$60k	Blue	$1,594	$2,480	2	7.20%
713497983	Male	40-49	$60k-$80k	Blue	$ 0	$3,459	2	7.12%
709253433	Female	50-59	$40k-$60k	Blue	$1,912	$2,448	2	6.98%
771075258	Male	50-59	>$120k	Silver	$1,527	$1,268	2	6.74%
716657058	Female	40-49	<$40k	Blue	$926	$1,566	3	6.73%
719621958	Male	40-49	$60k-$80k	Blue	$ 0	$1,720	3	6.66%
788965683	Female	40-49	<$40k	Blue	$ 0	$2,170	3	6.61%
709879458	Female	50-59	Unknown	Blue	$1,376	$1,881	3	6.53%
787467858	Male	40-49	$80k-$120k	Silver	$2,045	$4,081	3	6.47%
788465583	Female	40-49	$40k-$60k	Blue	$1,573	$3,029	3	6.35%
803776533	Male	40-49	$60k-$80k	Blue	$ 0	$2,118	2	6.30%
719038008	Female	40-49	<$40k	Blue	$1,192	$4,862	2	5.96%
708655983	Female	40-49	Unknown	Blue	$ 0	$1,353	2	5.84%
805259733	Female	50-59	Unknown	Blue	$ 0	$1,731	4	5.73%
710092683	Male	30-39	$80k-$120k	Blue	$1,421	$1,837	2	5.73%
755420433	Female	50-59	Unknown	Blue	$1,417	$1,068	3	5.70%
718361583	Female	50-59	Unknown	Blue	$ 0	$1,559	5	5.59%
789562383	Female	30-39	<$40k	Blue	$583	$1,259	0	5.54%
818908833	Male	40-49	$40k-$60k	Blue	$ 0	$2,038	2	5.53%
793059108	Female	50-59	$40k-$60k	Blue	$1,440	$893	3	5.50%
708664008	Male	50-59	$80k-$120k	Blue	$ 0	$1,222	4	5.50%
827111283	Male	40-49	$80k-$120k	Blue	$578	$1,109	2	5.49%
809342208	Male	<30	Unknown	Blue	$ 0	$2,005	2	5.38%
775112958	Male	50-59	$60k-$80k	Blue	$ 0	$7,781	3	5.38%
806637558	Male	50-59	$60k-$80k	Blue	$ 0	$1,539	5	5.36%
710632683	Male	30-39	$40k-$60k	Blue	$ 0	$2,308	3	5.36%
789270033	Male	40-49	$80k-$120k	Silver	$ 0	$1,122	3	5.33%
709986633	Male	<30	$40k-$60k	Blue	$ 0	$2,144	3	5.27%
715424283	Female	30-39	<$40k	Blue	$ 0	$3,059	2	5.27%
820075983	Male	<30	<$40k	Blue	$1,535	$2,299	2	5.24%
720846558	Male	40-49	$80k-$120k	Blue	$ 0	$2,512	4	5.20%
784798683	Male	30-39	$40k-$60k	Blue	$ 0	$1,999	2	5.16%
820596183	Male	50-59	>$120k	Blue	$2,395	$2,311	0	5.15%
754897008	Male	40-49	$40k-$60k	Blue	$1,418	$1,319	2	5.10%
716219808	Male	40-49	$60k-$80k	Blue	$ 0	$1,742	3	5.09%
808284783	Female	60+	<$40k	Blue	$ 0	$1,951	0	5.09%
779743908	Male	40-49	$60k-$80k	Blue	$ 0	$1,196	2	5.06%
713146683	Female	30-39	Unknown	Blue	$ 0	$5,473	2	5.02%
788210583	Male	60+	$40k-$60k	Blue	$ 0	$1,843	4	5.01%
712572858	Male	30-39	$80k-$120k	Blue	$1,801	$3,831	3	5.00%
808292958	Male	<30	<$40k	Blue	$495	$2,546	3	5.00%

The Attrition Timeline

NoteVisualizing Customer Life Expectancy

This final section uses survival analysis to map the customer lifecycle. Sudden drops in this curve indicate risk milestones - specific anniversary dates where customers are statistically most likely to reconsider their relationship with the bank. In this case, there appears to be a significant drop-off in customer retention at the three-year point. Perhaps this could be caused by new customers being offered three years of below-market financing, or other inducements. It’s certainly a good place to start further investigation.

#| label: survival-timeline

surv_obj <- attritionData %>%
  mutate(status = ifelse(attrition.flag == "Attrited Customer", 1, 0))

fit_km <- survfit(Surv(months.on.book, status) ~ 1, data = surv_obj)

ggsurvplot(fit_km, 
           data = surv_obj,
           palette = "#df691a",
           title = "Customer Retention Probability by Tenure",
           xlab = "Months on Book (Customer Lifecycle)",
           ylab = "Retention Probability",
           ggtheme = theme_minimal())

Key Findings

The analysis of over 10,000 customer records confirms that attrition in the consumer credit card division is rarely a sudden event, but rather a slow behavioral drift. By utilizing a random forest model, the strongest predictors of churn that have been predicted are not demographic markers like age or income, but rather a sharp decline in “transaction velocity and average utilization. When a customer’s total transaction count drops or they cease maintaining a revolving balance, they may be signaling their intent to depart months before the account is actually closed.

Additionally, survival analysis identified a critical “tenure risk” at the 36-month milestone. This suggests that as customers reach their third anniversary with the bank, the initial product appeal or promotional incentives may be losing their efficacy. To mitigate this, a structural shift in the Customer Lifecycle Management process might be valuable - implementing automated stay-active incentives and product reviews specifically timed for this 3-year window.

This project only scratches the surface of how machine learing and logistic regression can help solve these types of challenges in the credit and risk markets.